﻿// Preprocessor.fs
//
// Copyright 2009 Sergey Mechtaev
//
// This program is free software; you can redistribute it and/or
// modify it under the terms of the GNU General Public License
// as published by the Free Software Foundation.


#light

namespace SmartCPP.Core.Preprocessor

open SmartCPP.Core.Parser.FileStructure
open SmartCPP.Core.Parser.Lexer
open SmartCPP.Core.Parser.TextLexer
open SmartCPP.Core.Parser
open System.IO
open Microsoft.FSharp

module Preprocessor =
    
    ///Preprocess given text 
    let start file_content file_name =
        
        let lexbuf =  Text.Lexing.LexBuffer<_>.FromChars file_content
        lexbuf.EndPos <-{ pos_bol = 0;
                          pos_fname=file_name;
                          pos_cnum=0;
                          pos_lnum=0 }
        
        let file = Parser.parse lexbuf
        
        (*
        printfn ""
        printf "%A" file
        printfn ""
        printfn ""
        *)
        
        ///Length of input file
        let root_length = file_content.Length
        
        ///Represents initial state of preprocessing file 
        let history_root = Binding.File (root_length, file_name, file_content)        
       
        ///Store macroses and their values.
        ///Map key is macro name.
        ///Map value is pair of 
        ///  agrument name list and 
        ///  pair of
        ///    macro value with their position in input text and 
        ///    list of argument names with their position in macro value
        let macros = ref (new Map<string, (string list)*(StringWithPosition*(string*int) list)>([]))
                
        /// Replace the macro text substrings corresponding to call_args
        /// Map key is macro parameter name, value is pair of parameter value and its local position
        /// text_start - position in text with macro call (global, without offset)
        let substitute macro_name (call_args:Map<string, string*int>) cur_history cur_offset text_start =
            let text = (fst (snd ((!macros).Item macro_name)))
            let macro_text_start = fst (snd text)
            let dir_text_position = snd text
            let subs positions text = 
                let uncomp = ref positions
                let new_text = ref (fst text)
                let history = ref history_root
                let offset = ref 0
                while not (List.isEmpty (!uncomp)) do           
                    let name, pos = List.head !uncomp
                    uncomp := List.tail !uncomp                                        
                    let value = call_args.Item name
                    let value_length = String.length (fst value)
                    let value_pos = snd value
                    //printf "%A" !new_text 
                    history := Binding.Changed 
                        ((value_length-name.Length)+(Binding.textLength !history), 
                        (!history), 
                        (macro_text_start+pos, name.Length), 
                        Binding.Substring (cur_history, (cur_offset+text_start+value_pos,value_length)))
                    offset := (!offset+value_length-name.Length)
                    new_text := (!new_text:string).Substring (0,pos) + fst value + (!new_text).Substring (pos+name.Length, (!new_text).Length-pos-name.Length)
                (!new_text, Binding.Substring (!history, dir_text_position))
            let args = (snd (snd ((!macros).Item macro_name)))
            subs args text
                
        ///Process all macro calls in given text
        let process_text textWithPosition cur_history cur_offset =     
            
            let text = fst textWithPosition
            
            let text_start = fst (snd textWithPosition)
            
            let rec merge l1 l2 l3 =
                if List.length l1 = 0 then l3
                else merge (List.tail l1) (List.tail l2) ( (List.head l1, List.head l2)::l3 )
                   
            let rec prcss (text:string) comp_glob cur_history cur_global_offset cur_text_offset =
                let cur_length = Binding.textLength cur_history            
                if (text.Length = 0) then (comp_glob, cur_history, cur_global_offset)
                else
                    let comp, notcomp, new_history, new_offset, new_text_offset =
                        let lexbuf = Text.Lexing.LexBuffer<_>.FromChars (text.ToCharArray())
                        let call_string, call_beg = TextLexer.macroToken 0 lexbuf
                        if call_string.Equals("") then (text,"", cur_history, cur_offset, cur_text_offset+text.Length)
                        else 
                            let lexbuf = Text.Lexing.LexBuffer<_>.FromChars (call_string.ToCharArray())
                            let name, name_beg = TextLexer.callToken 0 lexbuf
                            let beg_part = text.Substring(0, call_beg)
                            let beg_with_name = beg_part+ call_string.Substring (0, name_beg + name.Length)
                            let end_part = text.Substring (call_beg+call_string.Length, text.Length-(call_beg+call_string.Length))
                            let end_with_args = call_string.Substring (name_beg+name.Length, call_string.Length-name_beg-name.Length) + end_part
                            if (!macros).ContainsKey name then
                                let rec read_args l pos=
                                    let next = TextLexer.callToken pos lexbuf
                                    if fst next = "" then l
                                    else read_args (next::l) (pos+snd next)
                                let args_values = List.rev (read_args [] (call_beg+name_beg+name.Length))
                                let args_name = fst ((!macros).Item name)                        
                                if List.length args_values = List.length args_name then                                    
                                    let pairs = List.rev (merge args_name args_values [] )
                                    let subs_string, subs_history = substitute name (Map.ofList pairs) cur_history cur_offset (cur_text_offset+text_start)
                                    let subs_offset = (String.length subs_string) - (String.length call_string)
                                    //printf "%A" (cur_global_offset, cur_text_offset, call_beg, text_start, call_string.Length)
                                    let history = Binding.Changed ((cur_length+subs_offset), cur_history, (cur_global_offset+cur_text_offset+call_beg+text_start, call_string.Length), subs_history)
                                    ("",beg_part + subs_string + end_part, history, cur_offset, cur_text_offset)
                                else 
                                    if List.length args_name = 0 then 
                                        let subs_string, subs_history = substitute name Map.empty cur_history cur_offset (cur_text_offset+text_start)
                                        let subs_offset = (String.length subs_string) - (String.length call_string)
                                        let history = Binding.Changed ((cur_length+subs_offset), cur_history, (cur_global_offset+cur_text_offset+call_beg+text_start, call_string.Length), subs_history)
                                        ("", beg_part + subs_string + end_part, history, cur_offset, cur_text_offset)
                                    else  
                                        (beg_with_name, end_with_args, cur_history, cur_global_offset, cur_text_offset+beg_with_name.Length) 
                            else 
                                if name.Equals "" then (text,"", cur_history, cur_global_offset, cur_text_offset+text.Length) 
                                else (beg_with_name, end_with_args, cur_history, cur_global_offset, cur_text_offset+beg_with_name.Length)                    
                    //System.Console.In.Read () |> ignore
                    prcss notcomp (comp_glob+comp) new_history new_offset new_text_offset
            prcss text "" cur_history cur_offset 0           
        
        
        let rec process_list f p1 p2 l =
            match l with
                | [] -> ("", p1, p2)
                | h::t ->
                    let str, new_p1, new_p2 = f h p1 p2
                    let res_str, res_p1, res_p2 = process_list f new_p1 new_p2 t
                    (str+res_str, res_p1, res_p2)
                    
        ///process file element
        ///cur_history - Binding.Text representing current state
        ///cur_offset - offset relative to source file positions
        let rec process_element file_element cur_history cur_offset =
            let cur_length = Binding.textLength cur_history
            match file_element with
                | DefineElement ((name,args,text),seg) ->
                    let lexbuf = Text.Lexing.LexBuffer<_>.FromChars ((fst text).ToCharArray())
                    let rec find_args param pos =
                        let id, id_pos = TextLexer.parameterToken pos lexbuf
                        if id.Equals("") then param
                        else
                            if List.exists (fun x -> x.Equals(id)) (List.map fst args) then find_args ((id, id_pos)::param) (id_pos+id.Length)
                            else find_args param (id_pos+id.Length)
                    macros := (!macros).Add(fst name, (List.map fst args, (text,(find_args [] 0))))
                    let new_text = " "
                    let new_history = Binding.Changed ((cur_length - (snd seg) + 1), cur_history, (Binding.addOffset seg cur_offset),Binding.String (1, new_text))
                    let new_offset = cur_offset+1-(snd seg)
                    (new_text, new_history , new_offset)
                | ConditionalElement (ifdir, then_elem, else_elem) -> //TODO correct processing                
                    match ifdir with
                        | (Expression (s,_),(dir_start, dir_length))-> (" ", cur_history, cur_offset+1-dir_length) //TODO expression
                        | (MacroId (n,_),_) -> //TODO position
                            if (!macros).ContainsKey n then process_list process_element cur_history cur_offset then_elem
                            else process_list process_element cur_history cur_offset else_elem
                | TextElement text -> process_text text cur_history cur_offset
                | IncludeElement file_name ->
                    //TODO include
                    let ((name, name_pos), seg) = file_name
                    ("#include "+name+"\n", cur_history, cur_offset+10+name.Length-snd seg)     
        let text, history, offset = match file with FileElementsList l -> process_list process_element history_root 0 l
        (text, history)